home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / aijournl / 1986_11 / pfl.lsp < prev    next >
Text File  |  1986-10-04  |  15KB  |  424 lines
  1.  
  2.                           PFL Language
  3.                           by Tim Finin
  4.                               from: 
  5.            November & December 1986 AI EXPERT article
  6.                  "Understanding Frame Languages"
  7.  
  8.  
  9.                             fdcl.lisp
  10.  
  11. ;;; -*- Mode: LISP; Syntax: Zetalisp; Base: 10 -*-
  12.  
  13. ;;; copyright (c) 1985 Tim Finin (tim@cis.upenn.edu)
  14.  
  15. ;;; this file defines/loads the PFL system.
  16.  
  17. #+ symbolics
  18. (defpackage pfl
  19.    (:export fput frame fslots ffacets fget fvalues fremove ferase
  20.             framep fsubsumes fdefineq fdefine ako instance subsumes-if
  21.             subsumed-if))
  22.  
  23. #+ symbolics
  24. (defsystem pfl
  25.    (:name "Pedagogic Frame Representation Language")
  26.    (:package "pfl")
  27.    (:pathname-default "upenn:usr:[tim.frames]")è   (:module pflvariables ("pflvariables"))
  28.    (:module pflmacros ("pflmacros"))
  29.    (:module pflbase ("pflbase"))
  30.    (:module pfldisplay ("pfldisplay"))
  31.    (:module pflthing ("thing"))
  32.  
  33.    (:compile-load pflvariables)
  34.    (:compile-load pflmacros)
  35.    (:compile-load pflbase (:fasload pflmacros))
  36.    (:compile-load pfldisplay (:fasload pflmacros))
  37.    (:load pflthing))
  38.  
  39. #+vax
  40. (progn
  41.   ;; VAXLISP system file for PFL.
  42.   (require 'pflvariables "pflvariables.lisp")
  43.   (require 'pflmacros "pflmacros.lisp")
  44.   (require 'pflbase "pflbase.lisp")
  45.   (require 'pfldisplay "pfldisplay.lisp")
  46.   (require 'pflthing "pflthing.lisp")
  47.   (export '(fput frame fslots ffacets fget fvalues fremove ferase
  48.             framep fsubsumes fdefineq fdefine
  49.             ako instance subsumes-if subsumed-if))
  50.   (provide 'pfl))
  51.  
  52.  
  53.  
  54.  
  55.                          fvariables.lisp
  56.  
  57. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
  58.  
  59. ;;; copyright (c) 1985 Tim Finin (tim@cis.upenn.edu)
  60.  
  61. ;;; This file binds and initializes the global variables used in PFL.
  62.  
  63. (defvar *frames* nil)    ; a list of all frames in existence.
  64. (defvar *fdemons* t)     ; should demons be triggered by default?
  65. (defvar *finherit* t)    ; should inheritance be done by default?
  66. (defvar *fdefault* t)    ; should default-values be used by default?
  67. (defvar *ftype* t)       ; should type checking be done by default?
  68. (defvar *fnumber* t)     ; should :min and :max checking be done by default?
  69.  
  70. (provide 'pflvariables)
  71.  
  72.  
  73.  
  74.  
  75.                           fmacros.lisp
  76.  
  77. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
  78.  
  79. ;;; copyright (c) 1985 Tim Finin (tim@cis.upenn.edu)
  80.  
  81. ;;; local macros and utilities used in PFL.è
  82. ;; syntactic sugar for a mapcar, some and every.
  83. (defmacro foreach (V in L &rest body) `(mapcar #'(lambda (,V) ,@body) ,L))
  84.  
  85. (defmacro forsome (V in L &rest body) `(some #'(lambda (,V) ,@body) ,L))
  86.  
  87. (defmacro forall (V in L &rest body) `(every #'(lambda (,V) ,@body) ,L))
  88.  
  89. (defmacro fwarn (msg &rest fillers) `(progn (format t ,msg ,@fillers) nil))
  90.  
  91. ;; applies a function to a list of things, then unions the results.
  92. (defun collect (function sequence)(reduce #'onion (mapcar function sequence)))
  93.  
  94. ;; like union, but works with 0 and 1 argument.
  95. (defun onion (&optional arg1 arg2) (union arg1 arg2))
  96.  
  97. (provide 'pflmacros)
  98.  
  99.  
  100.  
  101.  
  102.                            fbase.lisp
  103.  
  104. ;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: USER -*-
  105.  
  106. ;;; copyright (c) 1985 Tim Finin (tim@cis.upenn.edu)
  107.  
  108. ;;; this file provides the basic PFL functions.
  109.  
  110. ;;; SETTING FUNCTIONS ...
  111.  
  112. (defun fput (frame slot facet datum
  113.              &key (demons *fdemons*) (type *ftype*)
  114.                   (inherit *finherit*) (number *fnumber*))
  115.   ;; adds a datum to a slot if its not their already.
  116.   (cond ((member datum (fget-local frame slot facet)) datum)
  117.         ((equal facet :value)
  118.          (fput-value frame slot datum demons type inherit number))
  119.         (t (fput-add frame slot facet datum) datum)))
  120.  
  121. (defun fput-value (frame slot datum demons? type? inherit? number?)
  122.    ;; adds a value to a slot if the types are ok and the
  123.    ;; slot isn't full, then runs demons.
  124.    (unless (and type? (not (fcheck-types frame slot datum)))
  125.       (unless (and number? (not (fcheck-max frame slot)))
  126.          (fput-add frame slot :value datum)
  127.          (if demons?
  128.              (foreach demon in
  129.                    (fget frame slot :if-added :inherit inherit?)
  130.                    (funcall demon frame slot datum)))
  131.           datum)))
  132.  
  133. (defun fcheck-types (frame slot value)
  134.    ;; true iff value is subsumed by all of the slot's types.
  135.    (forall type in (fget frame slot :type)è      (or (fsubsumes type value)
  136.           (fwarn "~%;; ~S can't fit into ~S of ~S because it's
  137.                   not subsumed by ~S" value slot frame type))))
  138.  
  139. (defun fcheck-max (frame slot)
  140.    ;; true if there's room for another value.
  141.    (or (<= (length (fget-local frame slot :value))
  142.            (fget-slot-max frame slot))
  143.        (fwarn ";; Can't add another value to ~S of ~S" slot frame)))
  144.  
  145. (defun fcheck-min (frame slot)
  146.    ;; true if it's ok to remove a value
  147.    (or (> (length (fget-local frame slot :value))
  148.           (fget-slot-min frame slot))
  149.        (fwarn ";; Can't remove a value from ~S of ~S " slot frame)))
  150.  
  151. (defun fget-slot-max (f s)
  152.   ; returns the max-cardinality for slot S of frame F.
  153.   (let ((max (fget f s :max)))
  154.      (if max (car max) most-positive-fixnum)))
  155.  
  156. (defun fget-slot-min (f s)
  157.   ; returns the min-cardinality for slot S of frame F.
  158.   (let ((min (fget f s :min)))
  159.      (if min (car min) 0)))
  160.  
  161. (defun fput-add (frame slot facet datum)
  162.    ;; adds datum to specified (frame,slot,facet)
  163.    (rplacd (last (ffacet frame slot facet)) (list datum)))
  164.  
  165. (defun ffacet (frame slot facet)
  166.    ;; returns the expression representing the given facet of
  167.    ;; a particular frame and slot, creating it if neccessary.
  168.    (extend facet (extend slot (frame frame))))
  169.  
  170. (defun extend (key alist)
  171.    ;; like assoc, but adds key KEY if its not in the alist alIST.
  172.    (or (assoc key (cdr alist)) (cadr (rplacd (last alist)(list (list key))))))
  173.  
  174. ;;; ACCESSING FUNCTIONS ...
  175.  
  176. ;; returns the structure which represents the frame named F.
  177. (defun frame (f) (or (get f 'frame) (fcreate f)))
  178.  
  179. ;; returns a list of all local and inherited slots.
  180. (defun fslots (f &key (inherit *finherit*))
  181.    (if inherit
  182.        (collect 'fslots-local (flineage f))
  183.        (fslots-local f)))
  184.  
  185. (defun fslots-local (f)
  186.   "returns just the local slots of frame f"
  187.   (mapcar #'car (cdr (frame f))))
  188.  
  189. (defun ffacets (f s &key (inherit *finherit*))è  "returns a list of local and inherited facets for slot of frame"
  190.   (if inherit
  191.       (collect  #'(lambda (x) (ffacets-local x s)) (flineage f))
  192.       (ffacets-local f s)))
  193.  
  194. (defun ffacets-local (f s) (mapcar 'car (cdr (assoc s (cdr (frame f))))))
  195.  
  196. (defun fget (frame slot facet &key (inherit *finherit*)
  197.                    (demons *fdemons*) (default *fdefault*))
  198.   (if (equal facet :value)
  199.       (fvalues frame slot :inherit inherit :demons demons :default default)
  200.       (fget1 frame slot facet inherit)))
  201.  
  202. (defun fget1 (frame slot facet inherit?)
  203.    ;; returns list of data for the given frame, slot and facet
  204.    (or (fget-local frame slot facet)
  205.        (if inherit?
  206.            (forsome parent in (fparents frame)
  207.                (fget1 parent slot facet t)))))
  208.  
  209. (defun fget-local (frame slot facet)
  210.    ;; returns the data in a facet w/o inheritance or demons.
  211.    (cdr (assoc facet (cdr (assoc slot (cdr (frame frame)))))))
  212.  
  213. (defun fvalues (f s &key (inherit *finherit*) (demons *fdemons*)
  214.                (default *fdefault*) (finitial f))
  215.    ;; returns values from frame F slot S, local or inherited.
  216.    (or (fget-local f s :value)
  217.        (and default (fget-local f s :default))
  218.        (and demons (forsome demon in (fget-local f s :if-needed)
  219.                       (listify (funcall demon finitial s))))
  220.        (and inherit
  221.             (forsome parent in (fparents f)
  222.                 (fvalues parent s :inherit t
  223.                                   :demons demons
  224.                                   :default default
  225.                                   :finitial finitial)))))
  226.  
  227. (defun listify (l) (if (and l (atom l)) (list l) l))
  228.  
  229. (defun fvalue (frame slot &key (inherit *finherit*) (demons *fdemons*)
  230.                    (default *fdefault*))
  231.   "returns the 1st value in the specified slot"
  232.    (car (fvalues frame slot :inherit inherit :demons demons :default default)))
  233.  
  234. ;; returns the immediate parents of frame f.
  235. (defun fparents (f) (fget-local f 'ako :value))
  236.  
  237. ;; returns a list of F and all of F's ancestor frames.
  238. (defun flineage (f) (cons f (collect #'flineage (fparents f))))
  239.  
  240. ;;; FUNCTIONS TO REMOVE FRAMES, ETC. ...
  241.  
  242. (defun fremove (frame slot facet datum
  243.                 &key (demons *fdemons*)è                     (inherit *finherit*)
  244.                      (number *fnumber*))
  245.    ;; removes datum from frame's slot's facet and runs if-removed demons.
  246.    (when (and (member datum (fget-local frame slot facet))
  247.               (or (not (eq facet :value)) (fcheck-min frame slot)))
  248.          (delete datum (ffacet frame slot facet))
  249.          (if (and (eq facet :value) demons)
  250.              (foreach demon in (fget frame slot :if-removed :inherit inherit)
  251.                 (funcall demon frame slot datum)))))
  252.  
  253. (defun ferase (f &key (demons *fdemons*) (inherit *finherit*))
  254.   "erases a frame, piece by piece (so that demons can fire)"
  255.   (foreach slot in (append (delete 'ako (fslots-local f)) '(ako))
  256.      (foreach facet in (ffacets-local f slot)
  257.         (foreach datum in (fget-local f slot facet)
  258.            (fremove f s facet datum :demons demons :inherit inherit))))
  259.   (setq *frames* (delete f *frames*))
  260.   (setf (get f 'frame) nil))
  261.  
  262. ;;; PREDICATES
  263.  
  264. (defun framep (f)
  265.   "returns T iff its argument is a frame"
  266.   (and (symbolp f) (get f 'frame) (member f *frames*)))
  267.  
  268. (defun fsubsumes (super sub)
  269.   "Does SUPER subsume SUB?  One of {sub,super} must be a frame."
  270.   (or (ako-chain sub super)
  271.       (ako-subsumes-if sub super)
  272.       (ako-subsumed-if sub super)))
  273.  
  274. (defun ako-chain (sub super)
  275.   "is there a chain of AKO likes from frame SUB to frame SUPER?"
  276.   (and (framep sub) (framep super) (ako-chain1 sub super)))
  277.  
  278. (defun ako-chain1 (sub super)
  279.   (or (equal sub super)
  280.       (forsome parent in (fparents sub) (ako-chain parent super))))
  281.  
  282. (defun ako-subsumes-if (sub super)
  283.   "is there a method on SUPER that says SUB is below it?"
  284.   (and (framep super)
  285.        (forsome pred in (fvalues super 'subsumes-if) (funcall pred sub))))
  286.  
  287. (defun ako-subsumed-if (sub super)
  288.   "is there a method on SUB that says SUPER is above it?"
  289.   (and (framep sub)
  290.        (forsome pred in (fvalues sub 'subsumed-if) (funcall pred sub))))
  291.  
  292. ;;; FUNCTIONS TO CREATE and DEFINE FRAMES
  293.  
  294. (defmacro fdefineq (frame parents &rest slots)
  295.    ;; defines a frame named FRAME with parents PARENTS and slots SLOTS
  296.    `(fdefine ',frame ',parents ',slots))
  297. è(defun fdefine (name parents slots)
  298.    ;; (re)defines a frame, arguments are evaluated.
  299.    (fcreate name)
  300.    (foreach p in (if (listp parents) parents (list parents))
  301.        (fput name 'ako :value p))
  302.    (foreach slot in slots
  303.      (foreach facet in (cdr slot)
  304.         (foreach datum in (cdr facet)
  305.           (fput name (car slot) (car facet) datum))))
  306.    name)
  307.  
  308. (defun fcreate (f)
  309.   "creates a frame with name F"
  310.   (setq *frames* (adjoin f *frames*))
  311.   (setf (get f 'frame) (list f)))
  312.  
  313. (provide 'pflbase)
  314.  
  315.  
  316.  
  317.  
  318.                           fdisplay.lisp
  319.  
  320. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
  321.  
  322. ;;; copyright (c) 1985 Tim Finin (tim@cis.upenn.edu)
  323.  
  324. ;;; This file defines functions to display frames, including:
  325. ;;;     fshow - show all data in all facets of all slots of a frame.
  326. ;;;     fshow-values - show just values of all slots of a frame.
  327.  
  328. (defun fshow (frame &key (inherit *finherit*))
  329.   ;; displays a frame
  330.   (format t "~%frame ~S" frame)
  331.   (foreach slot in (fslots frame :inherit inherit)
  332.      (format t "~%  slot ~S:" slot)
  333.      (foreach facet in (ffacets frame slot :inherit inherit)
  334.         (format t "~%    ~S = " facet)
  335.         (foreach datum in (fget frame slot facet :inherit inherit)
  336.            (format t "~S "  datum))))
  337.   frame)
  338.  
  339. (defun fshow-values (frame
  340.                      &key (inherit *finherit*)
  341.                           (demons *fdemons*)
  342.                           (default *fdefault*))
  343.   ;; displays values in a frame
  344.   (format t "~%frame ~S" frame)
  345.   (foreach slot in (fslots frame :inherit inherit)
  346.      (let ((values (fvalues frame slot
  347.                            :inherit inherit :demons demons :default default)))
  348.        (WHEN values
  349.              (format t "~%  ~S = " slot)
  350.              (foreach v in
  351.                       (if (atom values) (list values) values)è                      (format t "~S " v)))))
  352.   frame)
  353.  
  354. (provide 'pfldisplay)
  355.  
  356.  
  357.  
  358.  
  359.                           pflthing.lisp
  360.  
  361. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
  362.  
  363. ;;; copyright (c) 1985 Tim Finin (tim@cis.upenn.edu)
  364.  
  365. ;;; this is the default initialization file for the frame hierarchy.
  366. ;;; It sets up the hierarchy:
  367. ;;;
  368. ;;;     thing
  369. ;;;       frame         - subsumes all PFL frames.
  370. ;;;       slot          - subsumes all PFL slots.
  371. ;;;         ako         - the PFL AKO slot.
  372. ;;;         instance    - The PFL instance slot.
  373. ;;;       expression
  374. ;;;         list
  375. ;;;         number
  376.  
  377. (fdefineq thing nil   ; in the beginning was THING ...
  378.   (ako (:type frame)
  379.        (:if-added add-inverse)
  380.        (:if-removed remove-inverse))
  381.   (instance (:type frame)
  382.             (:if-added add-inverse)
  383.             (:if-removed remove-inverse)))
  384.  
  385. (defun add-inverse (frame slot value)
  386.        ;; add an inverse relation.
  387.       (fput value (fvalue slot 'inverse) ':value frame))
  388.  
  389. (defun remove-inverse (frame slot value)
  390.        ;; remove an inverse relation
  391.        (fremove value (fvalue slot 'inverse) ':value frame))
  392.  
  393. (defun add-symmetric (frame slot value) (fput value slot :value frame))
  394. (defun remove-symmetric (frame slot value) (fremove value slot :value frame))
  395.  
  396. ;; these are PFL related concepts....
  397.  
  398. (fdefineq frame thing (subsumes-if (:value framep)))
  399.  
  400. (fdefineq slot thing
  401.   (inverse (if-added (lambda (f s d) (fput d 'inverse f)))
  402.            (if-removed (lambda (f s d) (fremove d 'inverse f)))))
  403.  
  404. (fdefineq ako slot (inverse (:value instance)))
  405. è(fdefineq instance slot (inverse (:value ako)))
  406.  
  407. (fdefineq ILLEGAL nil
  408.   ;; this is a frame that subsumes nothing.
  409.   (subsumes-if (lambda (x) nil)))
  410.  
  411. ;; These are commonly useful concepts.
  412.  
  413. (fdefineq expression thing (subsumes-if (:value (lambda(x) t))))
  414.  
  415. (fdefineq list expression (subsumes-if (:value listp)))
  416.  
  417. (fdefineq number expression (subsumes-if (:value numberp)))
  418.  
  419. (provide 'pfl-thing)
  420. ))))
  421.  
  422. ;;; FUNCTIONS TO CREATE and DEFINE FRAMES
  423.  
  424. (